home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Cactus / Cactus #14 - Mandelbrot-Fractale (1988-10)(Commodore Amiga Creativ Und Software Usergruppe)(de).zip / Cactus #14 - Mandelbrot-Fractale (1988-10)(Commodore Amiga Creativ Und Software Usergruppe)(de).adf / Mandel-V2.5c.BAS < prev    next >
BASIC Source File  |  1988-08-17  |  22KB  |  687 lines
  1. InitScreen:
  2.       CLEAR,30000 : CLEAR,110000&
  3.       SCREEN 1,640,200,4,2
  4.       WINDOW 1,"    Mandelbrot - Bilder     Version 2.5c    20.3.1988     Dr.W.Friederichs",(0,0)-(631,186),0,1
  5.  
  6. InitVariables:
  7.       DIM f(15,2),old(100,3),hauptbild#(4862),teilbild#(4862),fasqr%(2000)
  8.       low=25 : medium=10 : high=1 : resol=low
  9.       ra=-2 : re=.5 : ia=-1.25 : ie=1.25 : v=1
  10.       farbnum=0 : oldnum=-1
  11.       display=0 : hauptbild=1 : teilbild=2 : newpic=0 : teil=0
  12.       
  13. LoadDataFiles:
  14.       ON ERROR GOTO FileNotFound
  15.       '----------Laden der Farbpalette
  16.       DATA 0,0,0,16,16,16,16,0,0
  17.       FOR i=0 TO 2
  18.         FOR j=0 TO 2
  19.           READ f(i,j)
  20.         NEXT j
  21.         PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
  22.       NEXT i
  23.       '----------Laden der Farbdaten aus Farbdatei
  24.       errorcode=0 : OPEN"df0:ManColor" FOR INPUT AS #1
  25.       LOCATE 2,1 : COLOR 2,0
  26.       IF errorcode=53 THEN
  27.         PRINT " Die Farb-Datei [ ManColor ] existiert nicht !"
  28.         PRINT " Bitte benutzen Sie die Option 'Farben speichern'"
  29.         PRINT " zum Anlegen der Datei"
  30.         FOR i=3 TO 15
  31.           FOR j=0 TO 2
  32.             f(i,j)=10
  33.           NEXT j
  34.           PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
  35.         NEXT i
  36.       ELSE
  37.         PRINT " Die Farb-Datei [ ManColor ] wird geladen !"
  38.         FOR i=3 TO 15
  39.           FOR j=0 TO 2
  40.             INPUT #1,f(i,j)
  41.           NEXT j
  42.           PALETTE i,f(i,0)/16,f(i,1)/16,f(i,2)/16
  43.         NEXT i
  44.       END IF
  45.       CLOSE#1
  46.       '----------Laden der Bilderbibliothek
  47.       errorcode=0 : OPEN"df0:ManLib" FOR INPUT AS #1
  48.       PRINT :PRINT 
  49.       IF errorcode=53 THEN
  50.         PRINT " Die Bibliothek-Datei [ ManLib ] existiert nicht !"
  51.         PRINT " Das Anlegen dieser Datei erfolgt automatisch"
  52.         OPEN"df0:ManLib" FOR OUTPUT AS #1
  53.         CLOSE#1
  54.         OPEN"df0:ManLib" FOR INPUT AS #1
  55.       ELSE
  56.         PRINT " Die Bibliothek-Datei [ ManLib ] wird geladen !"
  57.       END IF
  58.       WHILE NOT EOF(1)
  59.         oldnum=oldnum+1
  60.         FOR i=0 TO 3
  61.           INPUT#1,old(oldnum,i)
  62.         NEXT i
  63.       WEND
  64.       CLOSE#1
  65.       '----------Laden des Hauptbildes
  66.       PRINT :PRINT 
  67.       IF oldnum=-1 THEN
  68.         PRINT " Die Bild-Datei [ MainPicture ] existiert nicht !" 
  69.         PRINT " Bitte legen Sie diese Datei durch Berechnen"
  70.         PRINT " eines Bildes mit dem Faktor 1 an"
  71.       ELSE
  72.         PRINT " Die Bild-Datei [ MainPicture ] wird geladen !" 
  73.         PRINT " Bitte warten (Ladevorgang dauert etwa 15 sek)"
  74.         mra=-2 : mre=.5 : mia=-1.25 : mie=1.25 : mv=1
  75.         nr=0 : GOSUB PicLoad
  76.       END IF
  77.       GOSUB NewColor
  78.       ON ERROR GOTO ErrorText
  79.               
  80. MenuText:
  81.       COLOR 1,0
  82.       LINE(401,0)-(402,186),1,bf
  83.       '----------Farbpalette
  84.       LINE(420,0)-(460,24),1,b
  85.       FOR j=0 TO 2
  86.         LINE(492,8*j)-(620,8*(j+1)),1,b
  87.       NEXT j
  88.       FOR j=0 TO 15
  89.         LINE(425+24*(j MOD 8),29+12*INT(j/8))-(446+24*(j MOD 8),39+12*INT(j/8)),j,bf
  90.       NEXT j
  91.       LINE(424,28)-(447,40),1,b
  92.       LOCATE 1,60:PRINT "R"
  93.       LOCATE 2,60:PRINT "G"
  94.       LOCATE 3,60:PRINT "B"
  95.       LINE(401,54)-(631,54),1
  96.       '----------Optionen
  97.       FOR j=8 TO 17
  98.         LINE(424,8*j-8)-(440,8*j-2),1,b
  99.       NEXT j
  100.       LOCATE  8,57:PRINT "berechnen bzw. laden"
  101.       LOCATE  9,57:PRINT "Aufl"+CHR$(246)+"sung "+CHR$(228)+"ndern"
  102.       LOCATE 10,57:PRINT "Bild speichern"
  103.       LOCATE 11,57:PRINT "Hardcopy erstellen"
  104.       LOCATE 12,57:PRINT "Farben speichern"
  105.       LOCATE 13,57:PRINT "Farbanimation an/aus"
  106.       LOCATE 14,57:PRINT "Haupt/Teilbild tauschen""
  107.       LOCATE 15,57:PRINT "Faktor vergr"+CHR$(246)+CHR$(223)"ern"
  108.       LOCATE 16,57:PRINT "Faktor verkleinern"
  109.       LOCATE 17,57:PRINT "alte Bilder suchen"
  110.       LINE(401,140)-(631,140),1
  111.       '----------mathematische Daten
  112.       LINE(424,144)-(440,150),1,b
  113.       LOCATE 19,57:PRINT "Bildschirm / ";
  114.       COLOR 2,0:PRINT "Rechnung"
  115.       hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  116.       IF display=0 THEN printcolor=2 ELSE printcolor=1
  117.       GOSUB PrintData
  118.       
  119. MouseCheck:
  120.       WHILE MOUSE(0)=0:WEND
  121.       x=MOUSE(1) : y=MOUSE(2)
  122.       WHILE MOUSE(0)><0:WEND
  123. 5     IF x<402 THEN
  124.         GOSUB ChooseCoord
  125.       ELSEIF y<24 AND x>485 AND x<626 THEN
  126.         GOSUB ChangeColor
  127.       ELSEIF y>28 AND y<52 AND x>424 AND x<614 THEN
  128.         GOSUB ChooseColor
  129.       ELSEIF y>55 AND y<135 AND x>420 AND x<445 THEN
  130.         op=INT(y/8)-6
  131.         LINE(425,49+8*op)-(439,53+8*op),2,bf
  132.         ON op GOSUB CalcLoad,Resolution,PicSave,HardCopy,ColorSave,RotateColor,SwapPicture,IncFactor,DecFactor,PicShow
  133.         LINE(425,49+8*op)-(439,53+8*op),0,bf
  134.       ELSEIF y>144 AND y<151 AND x>420 AND x<445 THEN
  135.         GOSUB SwapPrintData
  136.       END IF
  137.       IF NOT maus THEN MouseCheck ELSE maus=0 : GOTO 5
  138.        
  139. FileNotFound:
  140.       errorcode=ERR
  141.       RESUME NEXT
  142.  
  143. ErrorText:
  144.       text$=" BASIC-Compiler Error"+STR$(ERR)+" "
  145.       GOSUB ShowText
  146.       RESUME NEXT
  147.       
  148. PicShow:
  149.       IF display=hauptbild THEN
  150.         hv=mv : hra=mra : hre=mre : hia=mia : hie=mie
  151.       ELSEIF display=teilbild THEN
  152.         hv=pv : hra=pra : hre=pre : hia=pia : hie=pie
  153.       ELSE
  154.         text$="Es wurde noch kein Hauptbild berechnet !"
  155.         GOTO ShowText
  156.       END IF
  157. 1     found=0 : vloop=2*hv
  158.       WHILE vloop<=8192
  159.         FOR i=0 TO oldnum
  160.           IF old(i,0)=vloop AND old(i,1)>=hra AND old(i,2)>=hia THEN
  161.             found=-1 : ra=old(i,1) : ia=old(i,2) : resol=old(i,3)
  162.             re=ra+2.5/vloop : ie=ia+2.5/vloop
  163.             x1=(ra-hra)*160*hv : x2=x1+400/vloop*hv : IF x2>400 THEN x2=400
  164.             y1=(hie-ie)*74.4*hv : y2=y1+186/vloop*hv
  165.             LINE(x1,y1)-(x2,y2),1,b
  166.             hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=vloop
  167.             printcolor=2 : GOSUB PrintData
  168.             '----------Mausabfrage
  169.             LINE(425,129)-(439,133),0,bf
  170.             WHILE MOUSE(0)=0 : WEND
  171.             x=MOUSE(1) : y=MOUSE(2)
  172.             WHILE MOUSE(0)><0 : WEND
  173.             IF display=teilbild THEN
  174.               PUT(0,0),teilbild#,PSET
  175.             ELSEIF display=hauptbild THEN
  176.               PUT(0,0),hauptbild#,PSET
  177.             END IF
  178.             IF NOT(x>420 AND x<445 AND y>128 AND y<134) THEN
  179.               v=vloop
  180.               maus=-1
  181.               RETURN
  182.             END IF
  183.           END IF
  184.         NEXT i
  185.         vloop=2*vloop
  186.       WEND
  187.       IF found THEN 1
  188.       RETURN
  189.         
  190. CalcLoad:
  191.       '---------- Ist MainPicture schon berechnet ?
  192.       IF display=0 AND v><1 THEN
  193.         LINE(0,0)-(400,186),0,bf
  194.         LOCATE 2,1:COLOR 2,0:PRINT " Das erste zu berechnende Bild mu"+CHR$(223)
  195.         PRINT " [ MainPicture ] sein ! Bitte w"+CHR$(228)+"hlen Sie den"
  196.         PRINT " Vergr"+CHR$(246)+CHR$(223)+"erungsfaktor 1 und starten Sie"
  197.         PRINT " die Berechnung des Hauptbildes"
  198.         COLOR 1,0
  199.         RETURN
  200.       END IF
  201.       '---------- Altes Bild vorher abspeichern ?
  202.       IF newpic AND sure THEN
  203.         PUT(0,0),teilbild#,PSET
  204.         display=teilbild :sure=0
  205.         text$="Gegebenenfalls dieses Bild erst abspeichern"
  206.         GOSUB ShowText
  207.         PUT(0,0),teilbild#,PSET
  208.         LINE(425,57)-(439,61),0,bf
  209.         RETURN
  210.       END IF
  211.       '---------- Von zur Zeit gespeichertem Bild verschieden ?
  212.       IF v=pv AND ra=pra AND ia=pia AND resol>=presol THEN
  213.         IF (display=hauptbild AND v><1) OR (display=teilbild AND v=1) THEN
  214.           GOTO SwapPicture
  215.         ELSE
  216.           text$="Dieses Bild sehen Sie gerade !!!"
  217.           GOTO ShowText
  218.         END IF
  219.       END IF
  220.       '---------- Hauptbild mit anderer Vergroesserung berechnen ?
  221.       IF v=1 AND oldnum><-1 AND resol>=old(0,3) THEN
  222.         PUT(0,0),hauptbild#,PSET
  223.         RETURN
  224.       END IF
  225.       '---------- Ist Bild auf Diskette gespeichert ?
  226.       hhv=v : hhra=ra : hhia=ia
  227.       GOSUB LibSearch
  228.       IF nr=oldnum+1 OR resol<old(nr,3) THEN Calculation ELSE PicLoad
  229.  
  230. ChooseCoord:
  231.       IF printcolor=1 THEN
  232.         IF display=teilbild THEN
  233.           v=pv : resol=presol
  234.         ELSEIF display=hauptbild THEN
  235.           v=mv : resol=mresol
  236.         END IF
  237.       END IF
  238.       IF display=0 THEN
  239.         LINE(0,0)-(400,186),0,bf                
  240.         text$="Vor Koordinatenwahl [ MainPicture ] berechnen !"
  241.         GOTO ShowText
  242.       ELSEIF display=hauptbild THEN
  243. 3       hv=mv : hra=mra : hre=mre : hia=mia : hie=mie
  244.       ELSEIF display=teilbild THEN
  245.         IF pv>=v THEN GOSUB SwapPicture : GOTO 3
  246.         hv=pv : hra=pra : hre=pre : hia=mia : hie=pie
  247.       END IF
  248.       hhra=ra : hhre=re : hhia=ia : hhie=ie
  249.       ra=hra+x/160/hv : re=ra+2.5/v
  250.       ie=hie-y/74.4/hv : ia=ie-2.5/v
  251.       IF re<=hre AND ia>=hia THEN
  252.         LINE(x,y)-(x+400/v*hv,y+186/v*hv),1,b
  253.         hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  254.         printcolor=2 : GOSUB PrintData
  255.         WHILE MOUSE(0)=0 : WEND
  256.         x=MOUSE(1) : y=MOUSE(2)
  257.         WHILE MOUSE(0)><0 : WEND
  258.         IF display=hauptbild THEN
  259.           PUT(0,0),hauptbild#,PSET
  260.         ELSE
  261.           PUT(0,0),teilbild#,PSET
  262.         END IF
  263.         maus=-1
  264.         RETURN
  265.       ELSE
  266.         ra=hhra : re=hhre : ia=hhia : ie=hhie
  267.       END IF
  268.       RETURN
  269.  
  270. IncFactor:
  271.       IF printcolor=1 THEN
  272.         IF display=hauptbild THEN
  273.           resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
  274.         ELSEIF display=teilbild THEN
  275.           resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
  276.         END IF
  277.       END IF
  278.       IF v<16384 THEN
  279.         v=v*2 : re=ra+2.5/v : ie=ia+2.5/v
  280.         hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  281.         printcolor=2 : GOSUB PrintData
  282.       END IF
  283.       RETURN
  284.        
  285. DecFactor:
  286.       IF printcolor=1 THEN
  287.         IF display=hauptbild THEN
  288.           resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
  289.         ELSEIF display=teilbild THEN
  290.           resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
  291.         END IF
  292.       END IF
  293.       IF v>1 THEN
  294.         v=v/2 : re=ra+2.5/v : ie=ia+2.5/v
  295.         hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  296.         printcolor=2 : GOSUB PrintData
  297.       END IF
  298.       RETURN
  299.  
  300. ChangeColor:
  301.       j=CINT((y-4)/8)
  302.       f(farbnum,j)=CINT((x-492)/8)
  303.       IF f(farbnum,j)<0 THEN
  304.         f(farbnum,j)=0
  305.       ELSEIF f(farbnum,j)>16 THEN
  306.         f(farbnum,j)=16
  307.       END IF
  308.       PALETTE farbnum,f(farbnum,0)/16,f(farbnum,1)/16,f(farbnum,2)/16
  309.       GOTO NewColor
  310.  
  311. ChooseColor:
  312.       LINE(424+24*(farbnum MOD 8),28+12*INT(farbnum/8))-(447+24*(farbnum MOD 8),40+12*INT(farbnum/8)),0,b
  313.       farbnum=INT((x-426)/24)+8*INT((y-29)/12)
  314.       LINE(424+24*(farbnum MOD 8),28+12*INT(farbnum/8))-(447+24*(farbnum MOD 8),40+12*INT(farbnum/8)),1,b
  315.           
  316. NewColor:
  317.       LINE(421,1)-(459,23),farbnum,bf
  318.       FOR j=0 TO 2
  319.         LINE(494,8*j+2)-(494+7.75*f(farbnum,j),8*j+6),1,bf
  320.         LINE(494+7.75*f(farbnum,j),8*j+2)-(618,8*j+6),0,bf
  321.       NEXT j
  322.       RETURN
  323.              
  324. Calculation:
  325.       LINE(0,0)-(400,186),0,bf
  326.       re=ra+2.5/v : ie=ia+2.5/v
  327.       hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  328.       printcolor=1 : GOSUB PrintData
  329.       rs=.006313131#/v*resol : is=.005913878#/v*resol
  330.       IF v>64 THEN max%=2000 ELSE max%=200+15*v
  331.       max%=max%*2^((resol>high)+(resol>medium))
  332.       sqrmax%=SQR(max%)
  333.       xp0%=0 : yp0=0
  334.       '----------Farbzuordnung
  335.       FOR fa%=0 TO sqrmax%
  336.         fasqr%(fa%)=3+(fa% MOD 4)
  337.       NEXT fa%
  338.       FOR fa%=sqrmax% TO max%
  339.         fasqr%(fa%)=7+(SQR(fa%) MOD 9)
  340.       NEXT fa%
  341.       fasqr%(max%)=0
  342.       dx%=resol : dy=resol*.44
  343.       IF resol=high THEN dy=1 : xp0%=3 : is=is/.44
  344.       ypa=yp0 : ype=ypa+dy
  345.       FOR i=ie TO ia STEP -is
  346.         xpa%=xp0% : xpe%=xpa%+dx%
  347.         FOR r=ra TO re STEP rs
  348.           real=0
  349.           imag=0
  350.           realquad=0
  351.           imagquad=0
  352.           fa%=0
  353.           WHILE realquad+imagquad<4 AND fa%<max%
  354.             xr=realquad-imagquad+r
  355.             imag=2*real*imag+i
  356.             real=xr
  357.             realquad=xr*xr
  358.             imagquad=imag*imag
  359.             fa%=fa%+1
  360.           WEND
  361.           IF MOUSE(0)><0 THEN CalculationStop
  362.           LINE(xpa%,ypa)-(xpe%,ype),fasqr%(fa%),bf
  363.           xpa%=xpe% : xpe%=xpe%+dx%
  364.         NEXT r
  365.         ypa=ype : ype=ype+dy
  366.       NEXT i
  367.       IF v=1 THEN
  368.         display=hauptbild
  369.         GET(0,0)-(400,186),hauptbild#
  370.         mra=ra :mre=re : mia=ia : mie=ie : mv=v : mresol=resol
  371.       ELSE
  372.         display=teilbild : teil=-1
  373.       END IF
  374.       GET(0,0)-(400,186),teilbild#
  375.       newpic=-1 : sure=-1
  376.       pra=ra : pre=re : pia=ia : pie=ie : pv=v : presol=resol
  377.       RETURN
  378.        
  379. CalculationStop:
  380.       IF display=hauptbild THEN
  381.         display=teilbild
  382.         GOSUB SwapPicture
  383.       ELSEIF display=teilbild THEN
  384.         display=hauptbild
  385.         GOSUB SwapPicture
  386.       ELSEIF display=0 THEN
  387.         LINE(0,0)-(400,186),0,bf
  388.       END IF
  389.       RETURN
  390.  
  391. Resolution:
  392.       IF printcolor=1 THEN
  393.         IF display=hauptbild THEN
  394.           resol=mresol : ra=mra : re=mre : ia=mia : ie=mie : v=mv
  395.         ELSEIF display=teilbild THEN
  396.           resol=presol : ra=pra : re=pre : ia=pia : ie=pie : v=pv
  397.         END IF
  398.       END IF
  399.       IF resol=low THEN
  400.         resol=medium
  401.       ELSEIF resol=medium THEN
  402.         resol=high
  403.       ELSEIF resol=high THEN
  404.         resol=low
  405.       END IF
  406.       hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  407.       printcolor=2 : GOTO PrintData
  408.       RETURN
  409.           
  410. PicSave:
  411.       IF display=0 THEN
  412.         LINE(0,0)-(400,186),0,bf
  413.         text$="Es existiert kein zu speicherndes Bild !"
  414.         GOTO ShowText
  415.       ELSEIF display=hauptbild AND newpic THEN
  416.         nr=0 : pra=mra : pia=mia : pv=mv : presol=mresol
  417.       ELSEIF display=teilbild AND newpic THEN
  418.         hhv=pv : hhra=pra : hhia=pia
  419.         GOSUB LibSearch
  420.       END IF
  421.       IF nr><oldnum+1 THEN
  422.         IF presol<old(nr,3) THEN
  423.           old(nr,3)=presol
  424.           OPEN"df0:ManLib" FOR OUTPUT AS #1
  425.           FOR i%=0 TO oldnum
  426.             PRINT #1,old(i%,0),old(i%,1),old(i%,2),old(i%,3)
  427.           NEXT i%
  428.           CLOSE#1
  429.         ELSE
  430.           text$="Dieses Bild existiert bereits"
  431.           GOTO ShowText
  432.         END IF
  433.       ELSE
  434.         OPEN"df0:ManLib" FOR APPEND AS #1
  435.         PRINT #1,pv,pra,pia,presol
  436.         CLOSE#1
  437.         oldnum=nr
  438.         old(oldnum,0)=pv : old(oldnum,1)=pra : old(oldnum,2)=pia : old(oldnum,3)=presol
  439.       END IF
  440.       OPEN"df0:ManPicture"+STR$(nr) FOR OUTPUT AS #1
  441.       FOR i%=0 TO 4862
  442.         PRINT #1,MKD$(teilbild#(i%));
  443.       NEXT i%
  444.       CLOSE#1
  445.       newpic=0
  446.       RETURN
  447.        
  448. ShowText:
  449.       tlen2=INT(LEN(text$)/2)
  450.       LINE(188-tlen2*8,12)-(204+tlen2*8,27),0,bf
  451.       LINE(188-tlen2*8,12)-(204+tlen2*8,27),2,b
  452.       LOCATE 3,25-tlen2:COLOR 2,0:PRINT text$:COLOR 1,0
  453.       WHILE MOUSE(0)=0 : WEND
  454.       x=MOUSE(1) : y=MOUSE(2)
  455.       WHILE MOUSE(0)><0 : WEND
  456.       IF display=teilbild THEN PUT(0,0),teilbild#,PSET ELSE PUT(0,0),hauptbild#,PSET
  457.       maus=-1
  458.       RETURN
  459.       
  460. ColorSave:
  461.       OPEN"df0:ManColor" FOR OUTPUT AS #1
  462.       FOR i%=3 TO 15
  463.         FOR j%=0 TO 2
  464.           PRINT #1,f(i%,j%);
  465.         NEXT j%
  466.       NEXT i%
  467.       CLOSE#1
  468.       RETURN
  469.  
  470. InverseColor:
  471.       FOR i%=0 TO 15
  472.         FOR j%=0 TO 2
  473.           f(i%,j%)=16-f(i%,j%)
  474.         NEXT j%
  475.         PALETTE i%,f(i%,0)/16,f(i%,1)/16,f(i%,2)/16
  476.       NEXT i%
  477.       RETURN
  478.        
  479. RotateColor:
  480.       weiter=-1
  481.       FOR k%=1 TO 13
  482.         fh0=f(3,0) : fh1=f(3,1) : fh2=f(3,2)
  483.         FOR i%=3 TO 14
  484.           FOR j%=0 TO 2
  485.             f(i%,j%)=f(i%+1,j%)
  486.           NEXT j%
  487.           PALETTE i%,f(i%,0)/16,f(i%,1)/16,f(i%,2)/16
  488.           IF MOUSE(0)><0 THEN
  489.             x=MOUSE(1) : y=MOUSE(2)
  490.             weiter=0
  491.             LINE(425,97)-(439,101),0,bf
  492.           END IF
  493.         NEXT i%
  494.         f(15,0)=fh0 : f(15,1)=fh1 : f(15,2)=fh2
  495.         PALETTE 15,f(15,0)/16,f(15,1)/16,f(15,2)/16
  496.       NEXT k%
  497.       IF weiter THEN RotateColor
  498.       IF x<421 OR x>444 OR y<95 OR y>111 THEN maus=-1
  499.       RETURN
  500.        
  501. PicLoad:
  502.       resol=old(nr,3) : newpic=0
  503.       OPEN"df0:ManPicture"+STR$(nr) FOR INPUT AS #1
  504.       FOR i%=0 TO 4862
  505.         teilbild#(i%)=CVD(INPUT$(8,1))
  506.       NEXT i%
  507.       CLOSE#1
  508.       PUT(0,0),teilbild#,PSET
  509.       IF nr><0 THEN
  510.         hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  511.         printcolor=1 : GOSUB PrintData
  512.         display=teilbild : teil=-1
  513.         pv=v : pra=ra : pre=re : pia=ia : pie=ie : presol=resol
  514.       ELSE
  515.         GET(0,0)-(400,186),hauptbild#
  516.         display=hauptbild : mresol=resol
  517.       END IF
  518.       RETURN
  519.   
  520. SwapPicture:
  521.       IF display=0 THEN
  522.         LINE(0,0)-(400,186),0,bf
  523.         text$="Es existiert kein berechnetes Bild !"
  524.         GOTO ShowText
  525.       ELSEIF display=teilbild THEN
  526.         PUT(0,0),hauptbild#,PSET
  527.         display=hauptbild
  528.         hhresol=mresol : hhra=mra : hhre=mre : hhia=mia : hhie=mie : hhv=mv
  529.         printcolor=1 : GOSUB PrintData
  530.       ELSEIF display=hauptbild THEN
  531.         IF NOT teil THEN
  532.           text$="Es existiert kein Teilbild !"
  533.           GOTO ShowText
  534.         ELSE
  535.           PUT(0,0),teilbild#,PSET
  536.           display=teilbild
  537.           hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
  538.           printcolor=1 : GOSUB PrintData
  539.         END IF
  540.       END IF
  541.       RETURN
  542.  
  543. LibSearch:
  544.       FOR nr=0 TO oldnum
  545.         IF old(nr,0)=hhv AND old(nr,1)=hhra AND old(nr,2)=hhia THEN RETURN
  546.       NEXT nr
  547.       RETURN
  548.                
  549. SwapPrintData:
  550.       IF printcolor=1 THEN
  551.         printcolor=2
  552.         hhresol=resol : hhra=ra : hhre=re : hhia=ia : hhie=ie : hhv=v
  553.       ELSE
  554.         printcolor=1
  555.         IF display=teilbild THEN
  556.           hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
  557.         ELSE
  558.           hhresol=mresol : hhra=-2 : hhre=.5 : hhia=-1.25 : hhie=1.25 : hhv=1
  559.           IF display=0 THEN printcolor=2
  560.         END IF
  561.       END IF
  562.       
  563. PrintData:
  564.       IF hhresol=low THEN
  565.         res$="niedr."
  566.       ELSEIF hhresol=medium THEN
  567.         res$="mittel"
  568.       ELSEIF hhresol=high THEN
  569.         res$="hoch  "
  570.       END IF
  571.       COLOR 1,0:LOCATE 21,53:PRINT "real : ";
  572.       COLOR printcolor,0:PRINT USING"##.####";hhra;
  573.       COLOR 1,0:PRINT " bis ";
  574.       COLOR printcolor,0:PRINT USING"##.####";hhre
  575.       COLOR 1,0:LOCATE 22,53:PRINT "imag : ";
  576.       COLOR printcolor,0:PRINT USING"##.####";hhia;
  577.       COLOR 1,0:PRINT " bis ";
  578.       COLOR printcolor,0:PRINT USING"##.####";hhie
  579.       COLOR 1,0:LOCATE 23,53:PRINT "Fakt.: ";
  580.       COLOR printcolor,0:PRINT USING"#####";hhv;
  581.       COLOR 1,0:PRINT " Aufl.: ";
  582.       COLOR printcolor,0:PRINT res$;
  583.       COLOR 1,0
  584.       RETURN
  585.        
  586. HardCopy:
  587.       IF display=hauptbild THEN
  588.         hhresol=mresol : hhra=mra : hhre=mre : hhia=mia : hhie=mie : hhv=mv
  589.       ELSE
  590.         hhresol=presol : hhra=pra : hhre=pre : hhia=pia : hhie=pie : hhv=pv
  591.       END IF
  592.       printcolor=1 : GOSUB PrintData
  593.       GOSUB InverseColor
  594.       IF AlreadyDeclared = 0 THEN
  595.         DECLARE FUNCTION AllocSignal%() LIBRARY
  596.         DECLARE FUNCTION AllocMem&()    LIBRARY
  597.         DECLARE FUNCTION FindTask&()    LIBRARY
  598.         DECLARE FUNCTION DoIO&()        LIBRARY
  599.         DECLARE FUNCTION OpenDevice&    LIBRARY
  600.         AlreadyDeclared = 1
  601.       END IF
  602.       sWindow&   = WINDOW(7)
  603.       sScreen&   = PEEKL(sWindow& + 46)
  604.       sViewPort& = sScreen& + 44
  605.       sRastPort& = sScreen& + 84
  606.       sColorMap& = PEEKL(sViewPort& + 4)
  607.       maxWidth%  = PEEKW(sScreen& + 12)
  608.       maxHeight% = PEEKW(sScreen& + 14)
  609.       viewModes% = PEEKW(sViewPort& + 32)
  610.       command%  = 11   'Drucker-Befehls-Nummer
  611.       srcX% = 0        'Sende ganzen Screen
  612.       srcY% = 0 
  613.       srcWidth%  = maxWidth%
  614.       srcHeight% = maxHeight%
  615.       destRows& = 0    
  616.       destCols& = 0
  617.       special% = &H84  'FullCol | Aspect
  618.       IF BorderFlag% = 0 THEN  'Kein Rahmen
  619.         srcX% = srcX% + 3
  620.         srcY% = srcY% + 11
  621.         srcWidth%  = srcWidth% - 3 - 11
  622.         srcHeight% = srcHeight% - 11 - 3
  623.       END IF   
  624.       LIBRARY "exec.library"
  625.       sigBit% =  AllocSignal%(-1)
  626.       ClearPublic& = 65537&
  627.       msgPort& = AllocMem&(40,ClearPublic&)
  628.       IF msgPort& = 0 THEN
  629.         PRINT "msgPort nicht allokierbar."
  630.         GOTO cleanup4
  631.       END IF
  632.       POKE(msgPort& + 8), 4 'Type=NT_MSGPORT
  633.       POKE(msgPort& + 9), 0 'Priority 0 
  634.       portName$ = "MyPrtPort"+CHR$(0)
  635.       POKEL(msgPort& + 10), SADD(portName$)
  636.       POKE(msgPort& + 14), 0 'Flags
  637.       POKE(msgPort& + 15), sigBit%
  638.       sigTask& = FindTask&(0)
  639.       POKEL(msgPort& + 16), sigTask&
  640.       CALL AddPort(msgPort&)  'Port hinzufuegen
  641.       ioRequest& = AllocMem&(64,ClearPublic&)
  642.       IF ioRequest& = 0  THEN
  643.         PRINT "ioRequest nicht allokierbar."
  644.         GOTO cleanup3
  645.       END IF
  646.       POKE(ioRequest& + 8),5 'Type=NT_MESSAGE
  647.       POKE(ioRequest& + 9),0 'Priority 0
  648.       POKEL(ioRequest& + 14), msgPort&
  649.       devName$ = "printer.device"+CHR$(0)
  650.       pError& = OpenDevice&(SADD(devName$),0,ioRequest&,0)
  651.       IF pError& <> 0  THEN
  652.         PRINT "Drucker nicht ansprechbar."
  653.         GOTO cleanup2
  654.       END IF
  655.       POKEW(ioRequest& + 28), command%
  656.       POKEL(ioRequest& + 32), sRastPort&
  657.       POKEL(ioRequest& + 36), sColorMap&
  658.       POKEL(ioRequest& + 40), viewModes%
  659.       POKEW(ioRequest& + 44), srcX%
  660.       POKEW(ioRequest& + 46), srcY%
  661.       POKEW(ioRequest& + 48), srcWidth%
  662.       POKEW(ioRequest& + 50), srcHeight%
  663.       POKEL(ioRequest& + 52), destCols&
  664.       POKEL(ioRequest& + 56), destRows&
  665.       POKEW(ioRequest& + 60), special%
  666.       ioError& = DoIO&(ioRequest&)
  667.       IF ioError& <> 0 THEN
  668.         PRINT "DumpRPort Fehler =" ioError&
  669.         GOTO cleanup1
  670.       END IF
  671. cleanup1:
  672.       CALL CloseDevice(ioRequest&)
  673. cleanup2:
  674.       POKE(ioRequest& + 8), &HFF
  675.       POKEL(ioRequest& + 20), -1
  676.       POKEL(ioRequest& + 24), -1
  677.       CALL FreeMem(ioRequest&,64)
  678. cleanup3:
  679.       CALL RemPort(msgPort&)
  680.       POKE(msgPort& + 8), &HFF  
  681.       POKEL(msgPort& + 20), -1
  682.       CALL FreeSignal(sigBit%)
  683.       CALL FreeMem(msgPort&,40)
  684. cleanup4:   
  685.       LIBRARY CLOSE
  686.       GOTO InverseColor
  687.